Programmer Plus 2007

home *** CD-ROM | disk | FTP | other *** search

/ Programmer Plus 2007 / Programmer-Plus-2007.iso / Programming / Microsoft Plateform / Visual Basic 5.0 / Msvb50.ace / msvb50 / MSVB50 / VB / SAMPLES / VISDATA / TABLEOBJ.FRM (.txt) < prev next >

Wrap

Visual Basic Form | 1996-10-16 | 29.7 KB | 921 lines

VERSION 5.00 Begin VB.Form frmTableObj ClientHeight = 3495 ClientLeft = 1335 ClientTop = 2625 ClientWidth = 5580 Height = 3960 HelpContextID = 2016145 Icon = "TABLEOBJ.frx":0000 KeyPreview = -1 'True Left = 1275 LinkTopic = "Form1" LockControls = -1 'True MDIChild = -1 'True ScaleHeight = 3480 ScaleMode = 0 'User ScaleWidth = 5593.989 ShowInTaskbar = 0 'False Tag = "Recordset" Top = 2220 Width = 5700 Begin VB.PictureBox picViewButtons Align = 1 'Align Top Appearance = 0 'Flat BorderStyle = 0 'None ForeColor = &H80000008& Height = 705 Left = 0 ScaleHeight = 705 ScaleMode = 0 'User ScaleWidth = 5577.292 TabIndex = 1 TabStop = 0 'False Top = 0 Width = 5580 Begin VB.ComboBox cboIndexes BackColor = &H00FFFFFF& BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 315 Left = 720 Style = 2 'Dropdown List TabIndex = 8 Top = 360 Width = 4335 End Begin VB.CommandButton cmdSeek Caption = "&Seek" BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 330 Left = 2835 TabIndex = 5 Top = 0 Width = 900 End Begin VB.CommandButton cmdFilter Caption = "F&ilter" BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 330 Left = 3735 TabIndex = 6 Top = 0 Width = 900 End Begin VB.CommandButton cmdClose Cancel = -1 'True Caption = "&Close" BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 330 Left = 4644 TabIndex = 7 TabStop = 0 'False Top = 0 Width = 900 End Begin VB.CommandButton cmdDelete Caption = "&Delete" BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 330 Left = 1935 TabIndex = 4 Top = 0 Width = 900 End Begin VB.CommandButton cmdEdit Caption = "&Edit" BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 330 Left = 1020 TabIndex = 3 Top = 0 Width = 900 End Begin VB.CommandButton cmdAdd Caption = "&Add" BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 330 Left = 0 TabIndex = 2 Top = 0 Width = 1020 End Begin VB.Label lblIndex Caption = "Index:" BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 120 TabIndex = 24 Top = 400 Width = 615 End End Begin VB.PictureBox picFieldHeader Appearance = 0 'Flat BorderStyle = 0 'None ForeColor = &H80000008& Height = 240 Left = 0 ScaleHeight = 240 ScaleMode = 0 'User ScaleWidth = 14948.92 TabIndex = 21 Top = 705 Width = 14946 Begin VB.Label lblFieldValue Caption = " Value (F4=Zoom) " BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 1680 TabIndex = 23 Top = 0 Width = 3165 End Begin VB.Label lblFieldHdr Caption = "Field Name:" BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 252 Left = 120 TabIndex = 22 Top = 0 Width = 1212 End End Begin VB.PictureBox picChangeButtons BorderStyle = 0 'None Height = 690 Left = 0 ScaleHeight = 690 ScaleMode = 0 'User ScaleWidth = 5658.375 TabIndex = 13 TabStop = 0 'False Top = 0 Visible = 0 'False Width = 5655 Begin VB.CommandButton cmdUpdate Caption = "&Update" BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 372 Left = 960 TabIndex = 15 Top = 48 Width = 1212 End Begin VB.CommandButton cmdCancel Caption = "&Cancel" BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 372 Left = 2640 TabIndex = 14 Top = 48 Width = 1212 End End Begin VB.PictureBox picStatBox Align = 2 'Align Bottom Appearance = 0 'Flat BorderStyle = 0 'None ForeColor = &H80000008& Height = 285 Left = 0 ScaleHeight = 298.153 ScaleMode = 0 'User ScaleWidth = 5584.009 TabIndex = 19 TabStop = 0 'False Top = 3204 Width = 5580 Begin VB.CommandButton cmdNext Caption = ">" Height = 287 Left = 4200 TabIndex = 11 Top = 0 Width = 375 End Begin VB.CommandButton cmdLast Caption = ">|" Height = 287 Left = 4575 TabIndex = 12 Top = 0 Width = 375 End Begin VB.CommandButton cmdFirst Caption = "|<" Height = 287 Left = 0 TabIndex = 9 Top = 0 Width = 375 End Begin VB.CommandButton cmdPrevious Caption = "<" Height = 287 Left = 375 TabIndex = 10 Top = 0 Width = 375 End Begin VB.Label lblStatus BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 735 TabIndex = 20 Top = 0 Width = 3360 End End Begin VB.VScrollBar vsbScrollBar Height = 2616 LargeChange = 3000 Left = 5040 SmallChange = 300 TabIndex = 18 Top = 960 Visible = 0 'False Width = 252 End Begin VB.PictureBox picFields Appearance = 0 'Flat BorderStyle = 0 'None ForeColor = &H80000008& Height = 375 Left = 120 ScaleHeight = 372 ScaleMode = 0 'User ScaleWidth = 4812 TabIndex = 16 TabStop = 0 'False Top = 960 Width = 4815 Begin VB.TextBox txtFieldData BackColor = &H00FFFFFF& DataSource = "Data1" BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00000000& Height = 288 Index = 0 Left = 1560 TabIndex = 0 Top = 0 Visible = 0 'False Width = 3252 End Begin VB.Label lblFieldName BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 252 Index = 0 Left = 0 TabIndex = 17 Top = 60 Visible = 0 'False Width = 1572 End End Attribute VB_Name = "frmTableObj" Attribute VB_Base = "0{529A44D1-C9E1-11CF-9ED2-00AA00574745}" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_TemplateDerived = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Attribute VB_Customizable = False Option Explicit '>>>>>>>>>>>>>>>>>>>>>>>> Const BUTTON1 = "&Add" Const BUTTON2 = "&Edit" Const BUTTON3 = "&Delete" Const BUTTON4 = "&Close" Const BUTTON5 = "&Seek" Const BUTTON6 = "F&ilter" Const BUTTON7 = "&Cancel" Const BUTTON8 = "&Update" Const Label1 = "Field NAme:" Const Label2 = "Value (F4=Zoom)" Const MSG1 = "Add record" Const MSG2 = "Field Length Exceeded, Data Truncated!" Const MSG3 = "Delete Current Record?" Const MSG4 = "Edit record" Const MSG5 = "Enter Filter Expression:" Const MSG6 = "Opening Table" Const MSG7 = "Resizing Form" Const MSG8 = "Enter Seek Parameters" Const MSG9 = "Record Not Found" '>>>>>>>>>>>>>>>>>>>>>>>> 'form variables Public mrsFormRecordset As Recordset Dim msTableName As String 'form recordset table name Dim mvBookMark As Variant 'form bookmark Dim mbEditFlag As Integer 'edit mode Dim mbAddNewFlag As Integer 'add mode Dim mbDataChanged As Integer Dim mfrmSeek As New frmSeek 'seek form instance Dim mlNumRows As Long 'total rows in Table Private Sub cmdAdd_Click() On Error GoTo AddErr 'set the mode mrsFormRecordset.AddNew lblStatus.Caption = MSG1 mbAddNewFlag = True If mrsFormRecordset.RecordCount > 0 Then mvBookMark = mrsFormRecordset.Bookmark Else mvBookMark = vbNullString End If picChangeButtons.Visible = True picViewButtons.Visible = False cmdNext.Enabled = False cmdFirst.Enabled = False cmdLast.Enabled = False cmdPrevious.Enabled = False ClearDataFields Me, mrsFormRecordset.Fields.Count txtFieldData(0).SetFocus Exit Sub AddErr: ShowError End Sub Private Sub cmdCancel_Click() On Error Resume Next picChangeButtons.Visible = False picViewButtons.Visible = True cmdNext.Enabled = True cmdFirst.Enabled = True cmdLast.Enabled = True cmdPrevious.Enabled = True mbEditFlag = False mbAddNewFlag = False If Len(mvBookMark) > 0 Then mrsFormRecordset.Bookmark = mvBookMark DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False DBEngine.Idle dbFreeLocks End Sub Private Sub txtFieldData_Change(Index As Integer) 'just set the flag if data is changed 'it gets reset to false when a new record is displayed mbDataChanged = True End Sub Private Sub txtFieldData_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer) If KeyCode = &H73 Then 'F4 lblFieldName_DblClick Index ElseIf KeyCode = 34 And vsbScrollBar.Visible Then 'pagedown with > 10 fields vsbScrollBar.Value = vsbScrollBar.Value - 3000 ElseIf KeyCode = 33 And vsbScrollBar.Visible Then 'pageup with > 10 fields vsbScrollBar.Value = vsbScrollBar.Value + 3000 End If End Sub Private Sub txtFieldData_KeyPress(Index As Integer, KeyAscii As Integer) 'only allow return when in edit of add mode If mbEditFlag Or mbAddNewFlag Then If KeyAscii = 13 Then KeyAscii = 0 SendKeys "{Tab}" End If 'throw away the keystrokes if not in add or edit mode ElseIf mbEditFlag = False And mbAddNewFlag = False Then KeyAscii = 0 End If End Sub Private Sub txtFieldData_LostFocus(Index As Integer) On Error GoTo FldDataErr If mbDataChanged Then 'store the data in the field mrsFormRecordset(Index) = txtFieldData(Index) End If 'reset for valid or error condition mbDataChanged = False Exit Sub FldDataErr: ShowError mbDataChanged = False End Sub Private Sub lblFieldName_DblClick(Index As Integer) On Error GoTo ZoomErr If mrsFormRecordset(Index).Type = dbText Or mrsFormRecordset(Index).Type = dbMemo Then If mrsFormRecordset(Index).Type = dbText Then gsZoomData = txtFieldData(Index).Text ElseIf mrsFormRecordset(Index).FieldSize() < gnGETCHUNK_CUTOFF Then gsZoomData = txtFieldData(Index).Text Else 'add the rest of the field data with getchunk MsgBar "Getting Memo Field Data", True Screen.MousePointer = vbHourglass gsZoomData = txtFieldData(Index).Text & StripNonAscii(mrsFormRecordset(Index).GetChunk(gnGETCHUNK_CUTOFF, gnMAX_MEMO_SIZE)) Screen.MousePointer = vbDefault MsgBar vbNullString, False End If frmZoom.Caption = Mid(lblFieldName(Index).Caption, 1, Len(lblFieldName(Index).Caption) - 1) frmZoom.Top = Top + 1200 frmZoom.Left = Left + 250 If mbAddNewFlag Or mbEditFlag Then frmZoom.cmdsave.Visible = True frmZoom.cmdCloseNoSave.Visible = True Else frmZoom.cmdClose.Visible = True End If If mrsFormRecordset(Index).Type = dbText Then frmZoom.txtZoomData.Text = gsZoomData frmZoom.Height = 1125 Else frmZoom.txtMemo.Text = gsZoomData frmZoom.txtMemo.Visible = True frmZoom.txtZoomData.Visible = False frmZoom.Height = 2205 End If frmZoom.Show vbModal If (mbAddNewFlag Or mbEditFlag) And gsZoomData <> "__CANCELLED__" Then If mrsFormRecordset(Index).Type = dbText And Len(gsZoomData) > mrsFormRecordset(Index).Size Then Beep MsgBox MSG2, 48 txtFieldData(Index).Text = Mid(gsZoomData, 1, mrsFormRecordset(Index).Size) Else txtFieldData(Index).Text = gsZoomData End If mrsFormRecordset(Index) = txtFieldData(Index).Text mbDataChanged = False End If End If Exit Sub ZoomErr: ShowError End Sub Private Sub cboIndexes_Click() On Error GoTo IndErr If mrsFormRecordset Is Nothing Then Exit Sub If mrsFormRecordset.Index = Mid(cboIndexes.Text, 1, InStr(1, cboIndexes.Text, ":") - 1) Then Exit Sub mrsFormRecordset.Index = Mid(cboIndexes.Text, 1, InStr(1, cboIndexes.Text, ":") - 1) DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False Exit Sub IndErr: ShowError End Sub Private Sub cmdClose_Click() Unload Me End Sub Private Sub vsbScrollBar_Change() Dim nTop As Integer nTop = vsbScrollBar If (nTop - 960) Mod gnCTLARRAYHEIGHT = 0 Then picFields.Top = nTop Else picFields.Top = ((nTop - 960) \ gnCTLARRAYHEIGHT) * gnCTLARRAYHEIGHT + 960 End If End Sub Private Sub cmdDelete_Click() On Error GoTo DelRecErr If MsgBox(MSG3, vbYesNo + vbQuestion) = vbYes Then mrsFormRecordset.Delete If gbTransPending Then gbDBChanged = True If mrsFormRecordset.EOF = False Then mrsFormRecordset.MoveNext End If mlNumRows = mlNumRows - 1 DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False End If Exit Sub DelRecErr: ShowError End Sub Private Sub cmdEdit_Click() On Error GoTo EditErr Dim nDelay As Long Dim nRetryCnt As Integer Screen.MousePointer = vbHourglass RetryEdit: mrsFormRecordset.Edit lblStatus.Caption = MSG4 mbEditFlag = True txtFieldData(0).SetFocus mvBookMark = mrsFormRecordset.Bookmark picChangeButtons.Visible = True picViewButtons.Visible = False cmdNext.Enabled = False cmdFirst.Enabled = False cmdLast.Enabled = False cmdPrevious.Enabled = False Screen.MousePointer = vbDefault Exit Sub EditErr: If Err = 3260 And nRetryCnt < gnMURetryCnt Then nRetryCnt = nRetryCnt + 1 DBEngine.Idle dbFreeLocks 'Wait gnMUDelay seconds nDelay = Timer While Timer - nDelay < gnMUDelay 'do nothing Wend Resume RetryEdit Else ShowError End If End Sub Private Sub cmdFilter_Click() On Error GoTo FilterErr Dim sFilter As String Dim frmDyn As New frmDynaSnap sFilter = InputBox(MSG5) If Len(sFilter) = 0 Then Exit Sub gsTableDynaFilter = "select * from " & AddBrackets(msTableName) & " where " & sFilter frmDyn.Show 'open recordset form w/ filtered table gsTableDynaFilter = vbNullString Exit Sub FilterErr: ShowError End Sub Private Sub cmdFirst_Click() On Error GoTo GoFirstError mrsFormRecordset.MoveFirst DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False Screen.MousePointer = vbDefault MsgBar vbNullString, False Exit Sub GoFirstError: ShowError End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If mbEditFlag Or mbAddNewFlag Then Exit Sub Select Case KeyCode Case 35 'end Call cmdLast_Click Case 36 'home Call cmdFirst_Click Case 38 'up arrow If Shift = 2 Then Call cmdFirst_Click Else Call cmdPrevious_Click End If Case 40 'down arrow If Shift = 2 Then Call cmdLast_Click Else Call cmdNext_Click End If End Select End Sub Private Sub Form_Load() Dim nFieldType As Integer Dim i As Integer Dim tdf As TableDef Dim idx As Index Dim sIndex As String On Error GoTo TableErr cmdAdd.Caption = BUTTON1 cmdEdit.Caption = BUTTON2 cmdDelete.Caption = BUTTON3 cmdClose.Caption = BUTTON4 cmdSeek.Caption = BUTTON5 cmdFilter.Caption = BUTTON6 cmdCancel.Caption = BUTTON7 cmdUpdate.Caption = BUTTON8 lblFieldHdr.Caption = Label1 lblFieldValue.Caption = Label2 Screen.MousePointer = vbHourglass MsgBar MSG6, True msTableName = mrsFormRecordset.Name Set tdf = gdbCurrentDB.TableDefs(msTableName) For Each idx In tdf.Indexes sIndex = idx.Name sIndex = sIndex & ":" & idx.Fields If idx.Unique Then sIndex = sIndex & ":Unique" Else sIndex = sIndex & ":Non-Unique" End If If idx.Primary Then sIndex = sIndex & ":Primary" End If cboIndexes.AddItem sIndex Next 'set the locking type If gsDataType = gsMSACCESS Then mrsFormRecordset.LockEdits = gnMULocking End If 'show the first record mlNumRows = mrsFormRecordset.RecordCount 'load the controls on the Table form lblFieldName(0).Visible = True txtFieldData(0).Visible = True nFieldType = mrsFormRecordset.Fields(0).Type txtFieldData(0).Width = GetFieldWidth(nFieldType) txtFieldData(0).TabIndex = 0 If nFieldType = dbText Then txtFieldData(0).MaxLength = mrsFormRecordset.Fields(0).Size For i = 1 To mrsFormRecordset.Fields.Count - 1 picFields.Height = picFields.Height + gnCTLARRAYHEIGHT Load lblFieldName(i) lblFieldName(i).Top = lblFieldName(i - 1).Top + gnCTLARRAYHEIGHT lblFieldName(i).Visible = True Load txtFieldData(i) txtFieldData(i).Top = txtFieldData(i - 1).Top + gnCTLARRAYHEIGHT txtFieldData(i).Visible = True nFieldType = mrsFormRecordset.Fields(i).Type txtFieldData(i).Width = GetFieldWidth(nFieldType) txtFieldData(i).TabIndex = i If nFieldType = dbText Then txtFieldData(i).MaxLength = mrsFormRecordset(i).Size Next 'resize main window If i <= 10 Then Me.Height = ((i + 1) * gnCTLARRAYHEIGHT) + 1600 Else Me.Height = 4668 Me.Width = Me.Width + 260 vsbScrollBar.Visible = True vsbScrollBar.Min = 900 vsbScrollBar.Max = 900 - (i * gnCTLARRAYHEIGHT&) + 2500 End If 'display the field names For i = 0 To mrsFormRecordset.Fields.Count - 1 lblFieldName(i).Caption = mrsFormRecordset(i).Name & ":" Next If cboIndexes.ListCount > 0 Then cboIndexes.ListIndex = 0 Else DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False End If Me.Width = 5508 Me.Left = 1000 Me.Top = 1000 Screen.MousePointer = vbDefault MsgBar vbNullString, False Exit Sub TableErr: ShowError Unload Me End Sub Private Sub Form_Resize() On Error Resume Next Dim nHeight As Integer Dim i As Integer Dim nTotWidth As Integer If WindowState <> 1 Then 'not minimized MsgBar MSG7, True 'make sure the form is lined up on a field nHeight = Me.Height If (nHeight - 1660) Mod gnCTLARRAYHEIGHT <> 0 Then Me.Height = ((nHeight - 1660) \ gnCTLARRAYHEIGHT) * gnCTLARRAYHEIGHT + 1660 End If 'resize the status bar picStatBox.Top = Me.Height - 650 'resize the scrollbar vsbScrollBar.Height = picStatBox.Top - (picViewButtons.Top - picFieldHeader.Height) - 1200 vsbScrollBar.Left = Me.Width - 360 If mrsFormRecordset.Fields.Count > 10 Then picFields.Width = Me.Width - 260 nTotWidth = vsbScrollBar.Left - 20 Else picFields.Width = Me.Width - 20 nTotWidth = Me.Width - 50 End If picFieldHeader.Width = Me.Width - 20 'widen the fields if possible For i = 0 To mrsFormRecordset.Fields.Count - 1 lblFieldName(i).Width = 0.3 * nTotWidth txtFieldData(i).Left = lblFieldName(i).Width + 20 If mrsFormRecordset(i).Type = dbText Or mrsFormRecordset(i).Type = dbMemo Then txtFieldData(i).Width = 0.7 * nTotWidth - 250 End If Next lblFieldValue.Left = txtFieldData(0).Left lblStatus.Width = Me.Width - 1600 cmdNext.Left = lblStatus.Width + 745 cmdLast.Left = cmdNext.Left + 370 End If MsgBar vbNullString, False End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next Unload mfrmSeek 'get rid of attached seek form mrsFormRecordset.Close 'close the form Table DBEngine.Idle dbFreeLocks MsgBar vbNullString, False End Sub Private Sub cmdLast_Click() On Error GoTo GoLastError mrsFormRecordset.MoveLast 'show the current record DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False Exit Sub GoLastError: ShowError End Sub Private Sub cmdNext_Click() On Error GoTo GoNextError mrsFormRecordset.MoveNext 'show the current record DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False Exit Sub GoNextError: ShowError End Sub Private Sub cmdPrevious_Click() On Error GoTo GoPrevError mrsFormRecordset.MovePrevious 'show the current record DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False Exit Sub GoPrevError: ShowError End Sub Private Sub cmdSeek_Click() On Error GoTo SeekErr Dim sBookMark As String If mrsFormRecordset.RecordCount = 0 Then Exit Sub SeekStart: MsgBar MSG8, False frmSeek.Show vbModal If Len(gsSeekValue) = 0 Then MsgBar vbNullString, False Exit Sub End If sBookMark = mrsFormRecordset.Bookmark Screen.MousePointer = vbHourglass mrsFormRecordset.Seek gsSeekOperator, gsSeekValue Screen.MousePointer = vbDefault 'return to old record if no match was found If mrsFormRecordset.NoMatch And Len(sBookMark) > 0 Then Beep MsgBox MSG9, 48 mrsFormRecordset.Bookmark = sBookMark GoTo SeekStart End If DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False MsgBar vbNullString, False Exit Sub SeekErr: Screen.MousePointer = vbDefault MsgBox Error Exit Sub End Sub Private Sub cmdUpdate_Click() On Error GoTo UpdateErr Dim nDelay As Long Dim nRetryCnt As Integer Screen.MousePointer = vbHourglass RetryUpd: mrsFormRecordset.Update If gbTransPending Then gbDBChanged = True If mbAddNewFlag Then mlNumRows = mlNumRows + 1 mrsFormRecordset.MoveLast 'move to the new record End If mbEditFlag = False mbAddNewFlag = False picChangeButtons.Visible = False picViewButtons.Visible = True cmdNext.Enabled = True cmdFirst.Enabled = True cmdLast.Enabled = True cmdPrevious.Enabled = True DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False DBEngine.Idle dbFreeLocks Screen.MousePointer = vbDefault Exit Sub UpdateErr: If Err = 3260 And nRetryCnt < gnMURetryCnt Then nRetryCnt = nRetryCnt + 1 mrsFormRecordset.Bookmark = mrsFormRecordset.Bookmark 'Cancel the update DBEngine.Idle dbFreeLocks nDelay = Timer 'Wait gnMUDelay seconds While Timer - nDelay < gnMUDelay 'do nothing Wend Resume RetryUpd Else ShowError End If End Sub